Attribute VB_Name = "Fullscreen"
'====================================================================================
'Fullscreen - Change screen resolution and fullscreen the app
'====================================================================================
Option Explicit

'Find window (to minimize VB6) ------------------------------------------------------
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal cCmdShow As Long) As Long

'Change Screen Resolution -----------------------------------------------------------
Private Type DEVMODE
    dmDeviceName As String * 32
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * 32
    dmUnusedPadding As Integer
    dmBitsPerPixel As Integer       'Bit depth, 8, 16, 24 or 32
    dmPelsWidth As Long             'Screen width
    dmPelsHeight As Long            'Screen height
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    dmICMMethod As Long
    dmICMIntent As Long
    dmMediaType As Long
    dmDitherType As Long
    dmReserved1 As Long
    dmReserved2 As Long
    dmPanningWidth As Long
    dmPanningHeight As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Declare Function ChangeDisplaySettings Lib "user32.dll" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Const ENUM_CURRENT_SETTINGS = -1
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H2
Private Const CDS_FULLSCREEN = &H4
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1

'Remove control box -----------------------------------------------------------------
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000     'WS_BORDER Or WS_DLGFRAME
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Enum ESetWindowPosStyles
    SWP_SHOWWINDOW = &H40
    SWP_HIDEWINDOW = &H80
    SWP_FRAMECHANGED = &H20
    SWP_NOACTIVATE = &H10
    SWP_NOCOPYBITS = &H100
    SWP_NOMOVE = &H2
    SWP_NOOWNERZORDER = &H200
    SWP_NOREDRAW = &H8
    SWP_NOREPOSITION = SWP_NOOWNERZORDER
    SWP_NOSIZE = &H1
    SWP_NOZORDER = &H4
    SWP_DRAWFRAME = SWP_FRAMECHANGED
    HWND_NOTOPMOST = -2
End Enum

'Show/hide the mouse pointer
Private Declare Function ShowCursor Lib "user32.dll" (ByVal bShow As Long) As Long

'------------------------------------------------------------------------------------
Private CurrentState As Boolean  'If the form is fullscreen

'====================================================================================
'IsFullscreen: Return true/false for current fullscreen status
'====================================================================================
Public Function IsFullscreen() As Boolean
    IsFullscreen = CurrentState
End Function

'====================================================================================
'Switch: Switch into or out of fullscreen mode
'====================================================================================
Public Function Switch(ByRef refForm As Form, ByVal IsEnabled As Boolean) As Boolean
    Static OldScreenMode As DEVMODE     'The settings before fullscreen
    Static OldWindowPosition As RECT    'Where the window was before
    Dim ScreenMode As DEVMODE           'display settings
    Dim r As Long                       'return value
    Dim C As Long                       'Loop counter
    
    'Ignore second calls to set it to the same thing
    If CurrentState = IsEnabled Then Exit Function
    
    'In order to use the API, the size of screenmode must be set
    ScreenMode.dmSize = Len(ScreenMode)
    
    'Are we going into or out of Fullscreen?
    If IsEnabled = True Then
        'Minimize VB6
        EnumWindows AddressOf EnumWindowsProc, ByVal 0&
        
        'Get the current display settings.
        r = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, ScreenMode)
        'Remember the screen mode before the change
        OldScreenMode = ScreenMode
        'Change the resolution settings to 640x480.
        ScreenMode.dmPelsWidth = 640
        ScreenMode.dmPelsHeight = 480
        '//ScreenMode.dmBitsPerPixel = 32
        'Test to make sure the changes are possible.
        r = ChangeDisplaySettings(ScreenMode, CDS_TEST)
        If r <> DISP_CHANGE_SUCCESSFUL Then
            'Fullscreen mode failed
            Switch = False
            Exit Function
        Else
            'Change to the new settings (just for this program)
            r = ChangeDisplaySettings(ScreenMode, CDS_FULLSCREEN)
            Switch = (r = DISP_CHANGE_SUCCESSFUL)
            'If fullscreen worked, hide the mouse pointer
            Do: C = ShowCursor(0): Loop Until C < 0
            'Remember the old size/position of the window
            GetWindowRect refForm.hWnd, OldWindowPosition
            'Hide the windows title bar
            p_ShowTitleBar refForm, False
            'Move the window to the top-left
            refForm.Move 0, 0, 640, 480
        End If
    Else
        'return to previous mode
        r = ChangeDisplaySettings(OldScreenMode, CDS_UPDATEREGISTRY)
        'Make the mouse pointer visible
        Do: C = ShowCursor(1): Loop Until C >= 0
        'Show the title bar again
        p_ShowTitleBar refForm, True
        'return the window to the previous location
        SetWindowPos refForm.hWnd, 0, OldWindowPosition.Left, OldWindowPosition.Top, OldWindowPosition.Right, OldWindowPosition.Bottom, 0&
    End If
    CurrentState = IsEnabled
End Function

'====================================================================================
'PRIVATE ShowTitleBar: Show/Hide the window frame and min/max/close buttons
'====================================================================================
Private Sub p_ShowTitleBar(ByRef refForm As Form, ByVal IsEnabled As Boolean)
    Dim lStyle As Long
    Dim tR As RECT

    'Get the window's current position
    GetWindowRect refForm.hWnd, tR

    'Get the current window style
    lStyle = GetWindowLong(refForm.hWnd, GWL_STYLE)
    'If the titlebar is to be switched on...
    If IsEnabled = True Then
        'put back the window's title text
        refForm.Caption = refForm.Tag
        'If the form had a control box, put it back on
        If refForm.ControlBox Then lStyle = lStyle Or WS_SYSMENU    'Close button...
        If refForm.MaxButton Then lStyle = lStyle Or WS_MAXIMIZEBOX 'Max button...
        If refForm.MinButton Then lStyle = lStyle Or WS_MINIMIZEBOX 'Min button...
        If refForm.Caption <> "" Then lStyle = lStyle Or WS_CAPTION 'Title bar...
    Else
        'Remember the title text before removing it
        refForm.Tag = refForm.Caption
        refForm.Caption = ""
        lStyle = lStyle And Not WS_SYSMENU      'Remove the X button (Control Box)
        lStyle = lStyle And Not WS_MAXIMIZEBOX  'Remove the Max button
        lStyle = lStyle And Not WS_MINIMIZEBOX  'Remove the Min button
        lStyle = lStyle And Not WS_CAPTION      'Remove the Title Bar
    End If
    'Apply the changes to the window
    SetWindowLong refForm.hWnd, GWL_STYLE, lStyle

    'Resize the window to account for the addded/removed borders etc
    SetWindowPos refForm.hWnd, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
    refForm.Refresh
End Sub

'====================================================================================
'PRIVATE EnumWindowProc
'====================================================================================
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
    Dim sSave As String, Ret As Long
    
    Ret = GetWindowTextLength(hWnd)
    sSave = Space(Ret)
    GetWindowText hWnd, sSave, Ret + 1
    If InStr(sSave, "Microsoft Visual Basic") > 0 Then
         ShowWindow hWnd, 6
    End If
    EnumWindowsProc = True
End Function

'=== END ============================================================================
'This work is licenced under the Creative Commons Attribution 2.5 License
